home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / risc_apply.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  8.9 KB  |  327 lines
  1. (herald risc_apply (env tsys))
  2.  
  3. (define (apply-traced-operation proc . args)
  4.   (lap (*traced-op-template*)
  5.     (load l (d@r P (static *traced-op-template*)) parassign-extra)
  6.     (load l (d@r parassign-extra 2) parassign-extra)
  7.     (jbr entry)))
  8.  
  9. (define (apply proc . args)
  10.  (lap ()                 
  11.   (move zero parassign-extra)
  12. entry
  13.   (sub ($ 2) NARGS)                        ;; shift proc out
  14.   (move A1 P)                         ;; first arg is proc
  15.   (j= NARGS zero apply-done)
  16.   (jn= NARGS ($ 1) next1)
  17.   (move A2 AN)
  18.   (jbr apply-one-arg)
  19. next1
  20.   (move A2 A1)
  21.   (jn= NARGS ($ 2) next2)
  22.   (move A3 AN)
  23.   (jbr apply-two-args)
  24. next2
  25.   (move A3 A2)
  26.   (jn= NARGS ($ 3) next3)
  27.   (move A4 AN)                
  28.   (jbr apply-three-args)
  29. next3
  30.   (move A4 A3)
  31.   (jn= NARGS ($ 4) next4)
  32.   (move A5 AN)                
  33.   (jbr apply-four-args)
  34. next4
  35.   (move A5 A4)
  36.   (jn= NARGS ($ 5) next5)
  37.   (move A6 AN)                
  38.   (jbr apply-five-args)
  39. next5
  40.   (move A6 A5)
  41.   (jn= NARGS ($ 6) next6)
  42.   (move A7 AN)                
  43.   (jbr apply-six-args)
  44. next6
  45.   (move A7 A6)
  46.   (jn= NARGS ($ 7) next7)
  47.   (move A8 AN)                
  48.   (jbr apply-seven-args)
  49. next7
  50.   (move A8 A7)
  51.   (jn= NARGS ($ 8) next8)
  52.   (move A9 AN)                
  53.   (jbr apply-eight-args)
  54. next8
  55.   (move A9 A8)
  56.   (jn= NARGS ($ 9) next9)
  57.   (move A10 AN)                
  58.   (jbr apply-nine-args)
  59. next9
  60.   (move A10 A9)
  61.   (jn= NARGS ($ 10) next10)
  62.   (move A11 AN)                
  63.   (jbr apply-ten-args)
  64. next10
  65.   (move A11 A10)
  66.   (jn= NARGS ($ 11) next11)
  67.   (move A12 AN)                
  68.   (jbr apply-eleven-args)
  69. next11
  70.   (move A12 A11)
  71.   (jn= NARGS ($ 12) next12)
  72.   (load l (d@r extra-args %%car) AN)                
  73.   (jbr apply-twelve-args)
  74. next12
  75.   (move extra-args extra)    ;save extra args
  76.   (load l (d@r extra %%car) A12)            ;; first argument temp
  77.   (sub ($ (+ *argument-registers* 1)) NARGS vector)             ;; S1 counts sown to 0
  78.   (jbr apply-shift-test)
  79. apply-shift-loop-top
  80.   (sub ($ 1) vector)
  81.   (load l (d@r extra %%cdr) extra)
  82. apply-shift-test
  83.   (jn= vector zero apply-shift-loop-top)
  84.   (load l (d@r extra %%cdr) an)
  85.   (load l (d@r an %%car) an)
  86.   (store l an (d@r extra %%cdr))
  87. count-list-test
  88.   (j= an nil-reg apply-done)
  89.   (load l (d@r an %%cdr) an)
  90.   (add ($ 1) nargs)
  91.   (jbr count-list-test)
  92. apply-one-arg
  93.   (j= AN nil-reg apply-done)
  94.   (load l (d@r an %%car) A1)                    
  95.   (add ($ 1) NARGS)
  96.   (load l (d@r an %%cdr) AN)                   
  97. apply-two-args
  98.   (j= AN nil-reg apply-done)
  99.   (load l (d@r an %%car) A2)                    
  100.   (add ($ 1) NARGS)
  101.   (load l (d@r an %%cdr) AN)                   
  102. apply-three-args
  103.   (j= AN nil-reg apply-done)
  104.   (load l (d@r an %%car) A3)                    
  105.   (add ($ 1) NARGS)
  106.   (load l (d@r an %%cdr) AN)                   
  107. apply-four-args
  108.   (j= AN nil-reg apply-done)
  109.   (load l (d@r an %%car) A4)                    
  110.   (add ($ 1) NARGS)
  111.   (load l (d@r an %%cdr) AN)                   
  112. apply-five-args
  113.   (j= AN nil-reg apply-done)
  114.   (load l (d@r an %%car) A5)                    
  115.   (add ($ 1) NARGS)
  116.   (load l (d@r an %%cdr) AN)                   
  117. apply-six-args
  118.   (j= AN nil-reg apply-done)
  119.   (load l (d@r an %%car) A6)                    
  120.   (add ($ 1) NARGS)
  121.   (load l (d@r an %%cdr) AN)                   
  122. apply-seven-args
  123.   (j= AN nil-reg apply-done)
  124.   (load l (d@r an %%car) A7)                    
  125.   (add ($ 1) NARGS)
  126.   (load l (d@r an %%cdr) AN)                   
  127. apply-eight-args
  128.   (j= AN nil-reg apply-done)
  129.   (load l (d@r an %%car) A8)                    
  130.   (add ($ 1) NARGS)
  131.   (load l (d@r an %%cdr) AN)                   
  132. apply-nine-args
  133.   (j= AN nil-reg apply-done)
  134.   (load l (d@r an %%car) A9)                    
  135.   (add ($ 1) NARGS)
  136.   (load l (d@r an %%cdr) AN)                   
  137. apply-ten-args
  138.   (j= AN nil-reg apply-done)
  139.   (load l (d@r an %%car) A10)                    
  140.   (add ($ 1) NARGS)
  141.   (load l (d@r an %%cdr) AN)                   
  142. apply-eleven-args
  143.   (j= AN nil-reg apply-done)
  144.   (load l (d@r an %%car) A11)                    
  145.   (add ($ 1) NARGS)
  146.   (load l (d@r an %%cdr) AN)                   
  147. apply-twelve-args
  148.   (j= AN nil-reg apply-done)
  149.   (load l (d@r an %%car) A12)                    
  150.   (add ($ 1) NARGS)
  151.   (load l (d@r an %%cdr) AN)                   
  152.   (move an extra-args)
  153.   (jbr count-list-test)
  154. apply-done                    
  155.   (jn= parassign-extra zero traced)
  156.   (load l (d@r p -2) parassign-extra)
  157. traced
  158.   (add ($ 2) parassign-extra extra)
  159.   (jr extra)
  160.   (noop)))
  161.  
  162.  
  163. (define (apply-init)
  164.   (lap ()
  165.     (movea %extra-args extra)
  166.     (store l extra (d@nil slink/make-extra-args))
  167.     (movea %nary-setup extra)
  168.     (store l extra (d@nil slink/nary-setup))
  169.     (jr link-reg)
  170.     (move ($ -1) nargs)
  171. %extra-args                ;bytes in scratch
  172.     (or ($ #b10000000) crit-reg)
  173.     (load l (d@nil slink/area-frontier) extra)
  174.     (add extra scratch)
  175.     (load l (d@nil slink/area-limit) vector)
  176.     (j> vector scratch %extra-args-heap-overflow)
  177.     (store l scratch (d@nil slink/area-frontier))
  178.     (add ($ 3) extra extra-args)
  179.     (add ($ 11) extra)
  180. extra-args-test
  181.     (j> extra vector extra-args-done)
  182.     (store l extra (d@r extra -11))
  183.     (add ($ 8) extra)
  184.     (jbr extra-args-test)
  185. extra-args-done
  186.     (store l nil-reg (d@r extra -11))
  187.     (mask ($ #x7f) crit-reg)
  188.     (jn= zero crit-reg %deferred-interrupts)
  189.     (jr link-reg)
  190.     (noop)
  191. %extra-args-heap-overflow
  192.     (store l t-reg (d@nil slink/doing-gc?))
  193.     (sub extra scratch)
  194.     (move link-reg extra)            ;heap overflow moves it back
  195.     (load l (d@nil slink/heap-overflow) link-reg)
  196.     (jalr link-reg)
  197.     (noop)
  198.     (store l nil-reg (d@nil slink/doing-gc?))
  199.     (jbr %extra-args)
  200.   
  201. %nary-setup                                 ; required args in vector
  202.   (sub ($ 1) NARGS)
  203.   (sub vector nargs parassign-extra)
  204.   (j= parassign-extra zero no-rest-args)
  205.   (sll ($ 3) parassign-extra)            ;bytes to cons
  206. %nary-setup-continue                        ; lose, lose
  207.   (or ($ #b10000000) crit-reg)
  208.   (load l (d@nil slink/area-frontier) AN)
  209.   (add an parassign-extra)
  210.   (load l (d@nil slink/area-limit) extra)
  211.   (j> extra parassign-extra %nary-make-pair-heap-overflow)
  212.   (store l parassign-extra (d@nil slink/area-frontier))
  213.   (add ($ 3) an)
  214.   (add ($ 8) an extra)
  215.   (j= vector zero move-a1)
  216.   (j= vector ($ 1) move-a2)
  217.   (j= vector ($ 2) move-a3)
  218.   (j= vector ($ 3) move-a4)
  219.   (j= vector ($ 4) move-a5)
  220.   (j= vector ($ 5) move-a6)
  221.   (j= vector ($ 6) move-a7)
  222.   (j= vector ($ 7) move-a8)
  223.   (j= vector ($ 8) move-a9)
  224.   (j= vector ($ 9) move-a10)
  225.   (j= vector ($ 10) move-a11)
  226.   (j= vector ($ 11) move-a12)
  227. many-loop
  228.   (load l (d@r extra-args %%car) vector)
  229.   (load l (d@r extra-args %%cdr) extra-args)
  230.   (store l vector (d@r extra -7))
  231.   (store l extra (d@r extra -11))
  232.   (add ($ 8) extra)
  233.   (add ($ 1) vector)
  234.   (j< vector nargs many-loop)
  235.   (jr link-reg)
  236.   (store l extra-args (d@r extra -11))
  237. move-a1
  238.   (store l a1 (d@r extra -7))
  239.   (store l extra (d@r extra -11))
  240.   (add ($ 8) extra)
  241.   (add ($ 1) vector)
  242.   (j>= vector nargs registers-moved)
  243. move-a2
  244.   (store l a2 (d@r extra -7))
  245.   (store l extra (d@r extra -11))
  246.   (add ($ 8) extra)
  247.   (add ($ 1) vector)
  248.   (j>= vector nargs registers-moved)
  249. move-a3
  250.   (store l a3 (d@r extra -7))
  251.   (store l extra (d@r extra -11))
  252.   (add ($ 8) extra)
  253.   (add ($ 1) vector)
  254.   (j>= vector nargs registers-moved)
  255. move-a4
  256.   (store l a4 (d@r extra -7))
  257.   (store l extra (d@r extra -11))
  258.   (add ($ 8) extra)
  259.   (add ($ 1) vector)
  260.   (j>= vector nargs registers-moved)
  261. move-a5
  262.   (store l a5 (d@r extra -7))
  263.   (store l extra (d@r extra -11))
  264.   (add ($ 8) extra)
  265.   (add ($ 1) vector)
  266.   (j>= vector nargs registers-moved)
  267. move-a6
  268.   (store l a6 (d@r extra -7))
  269.   (store l extra (d@r extra -11))
  270.   (add ($ 8) extra)
  271.   (add ($ 1) vector)
  272.   (j>= vector nargs registers-moved)
  273. move-a7
  274.   (store l a7 (d@r extra -7))
  275.   (store l extra (d@r extra -11))
  276.   (add ($ 8) extra)
  277.   (add ($ 1) vector)
  278.   (j>= vector nargs registers-moved)
  279. move-a8
  280.   (store l a8 (d@r extra -7))
  281.   (store l extra (d@r extra -11))
  282.   (add ($ 8) extra)
  283.   (add ($ 1) vector)
  284.   (j>= vector nargs registers-moved)
  285. move-a9
  286.   (store l a9 (d@r extra -7))
  287.   (store l extra (d@r extra -11))
  288.   (add ($ 8) extra)
  289.   (add ($ 1) vector)
  290.   (j>= vector nargs registers-moved)
  291. move-a10
  292.   (store l a10 (d@r extra -7))
  293.   (store l extra (d@r extra -11))
  294.   (add ($ 8) extra)
  295.   (add ($ 1) vector)
  296.   (j>= vector nargs registers-moved)
  297. move-a11
  298.   (store l a11 (d@r extra -7))
  299.   (store l extra (d@r extra -11))
  300.   (add ($ 8) extra)
  301.   (add ($ 1) vector)
  302.   (j>= vector nargs registers-moved)
  303. move-a12
  304.   (store l a12 (d@r extra -7))
  305.   (store l extra (d@r extra -11))
  306.   (add ($ 8) extra)
  307.   (add ($ 1) vector)
  308.   (j>= vector nargs registers-moved)
  309.   (jr link-reg)
  310.   (store l extra-args (d@r extra -11))
  311. registers-moved
  312.   (jr link-reg)
  313.   (store l nil-reg (d@r extra -11))
  314. no-rest-args
  315.   (jr link-reg)
  316.   (move nil-reg an)
  317. %nary-make-pair-heap-overflow
  318.     (store l t-reg (d@nil slink/doing-gc?))
  319.     (sub an vector)
  320.     (move link-reg extra)            ;heap overflow moves it back
  321.     (load l (d@nil slink/heap-overflow) link-reg)
  322.     (jalr link-reg)
  323.     (noop)
  324.     (store l nil-reg (d@nil slink/doing-gc?))
  325.     (jbr %nary-setup-continue)))
  326.  
  327. (apply-init)